Language/OS - Multiplatform Resource Library

home *** CD-ROM | disk | FTP | other *** search

/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / prolog / ai.prl / mike1.exe / ENGINE2.PL < prev next >

Wrap

Text File | 1990-09-17 | 22.1 KB | 598 lines

/* file: ENGINE2.PL {2nd part of main code for MIKE rule/frame engine} */ /* see also ENGINE1.PL for earlier bits! */ /* ************* M I K E ************* Micro Interpreter for Knowledge Engineering {written in Edinburgh-syntax Prolog} Copyright (C) 1989, 1990 The Open University (U.K.) This software accompanies Open University Study Pack PD624, 'KNOWLEDGE ENGINEERING'. Complete sets of study pack materials may be obtained from: Learning Materials Sales Office The Open University P.O. Box 188 Milton Keynes MK7 6DH, U.K. Tel: [+44] (908) 653338 Fax: [+44] (908) 653744 */ /* ENGINE1.PL & ENGINE2.PL contain the essential innards of MIKE. Some auxilliary code is contained in the files UTIL.PL and IO.PL, and the kernel of the forward chaining executive loop is in FC_EXEC.PL ENGINE1.PL & ENGINE2.PL are subdivided into six main parts, as follows: (N.B. the first three parts are in file ENGINE1.PL) 1. Backward chaining 2. Frame manipulation 3. Demon processing (N.B. the last three parts are in file ENGINE2.PL) 4. Top level 5. Forward chaining (left hand side conditions) 6. Forward chaining (right hand side actions) */ /* ===================== (4) T O P L E V E L ========================== */ A & B :- and(A & B). (X instance_of Y):- (X instance_of Y with _). (X subclass_of Y):- (X subclass_of Y with _). and(initialise):- initialise. and(go):- !, go. and(X & Y) :- and(X),and(Y). and(X):- perform1(X,New,'top level','You told me so'), retract('pd624 wme'(Whatever)), assert('pd624 wme'([New|Whatever])). fc:- initialise, add start, go. /* It would be faster to use 'continue' instead of 'go' in the line above, because 'go' now invokes part_initialise, which is actually redundant in this precise context. However, the above definition is published in the course text, so we stick with it. */ fc(X):- initialise, add X, go. /* See preceding comment about using 'continue' instead of 'go' */ add X :- /* fc triggers off the forward chainer */ assert(currentdb(X,true)), assert(justification(X,'top level','You told me so')), (retract('pd624 wme'(Whatever));Whatever = []), assert('pd624 wme'([X|Whatever])),!. remove X :- retract(currentdb(X,Truth)),!. remove X :- 'pd624 write'(['Sorry : ',X,' is not in working memory',nl, 'and thus cannot be removed',nl]). note ((A with B)) :- nonvar(B), retract((A with C)), /* previous definition? then warn user... */ 'pd624 write'(['Warning: overwriting previous definition of ',A,nl, ' with ',B,'. ',nl,'New definition is: ',A,nl,'with ',B,'. ',nl]), assert((A with B)),!. note ((A with B)) :- nonvar(B), assert((A with B)). /* come here if no previous definition */ note ((A with B)) :- var(B), /* anomalous case... inform user */ 'pd624 write'(['Error: ',B,' is a variable but must instead be ',nl, 'a legal frame body. No changes have resulted, and instruction',nl, 'will be ignored',nl]),!. /* ! protects 'pd624 write' */ note X:- perform1(note X,New,'top level','You told me so'), (retract('pd624 wme'(Whatever));Whatever = []), assert('pd624 wme'([New|Whatever])),!. deduce X :- prove(X). initialise:- fc_reset_history, /* reset history counters (see fc_exec.pl) */ abolish(currentdb,2), /* the relation 'currentdb/2' stores all WM items */ kill(currentdb), /* just for portability */ abolish(already_did,2), /* used for quick refractoriness test */ kill(already_did), assert(already_did(nil,nil)), /* need some assertion to avoid run-time complaint */ abolish('pd624 wme',1), /* otherwise we end up in a curious state?!!! */ kill('pd624 wme'), abolish(receives_answer,2), abolish(justification,3), assert('pd624 wme'([])), (retract(pd624_flag(_)) ; true), /* Used for single-step trace. See UTIL.PL */ initialise_back_door, /* in case of later extensions ! */ !. /* part_initialise is like initialise, but leaves WM alone, and also leaves justifications arising from top level use of ?- add ... */ part_initialise :- fc_reset_history, /* reset history counters (see fc_exec.pl) */ abolish(already_did,2), /* used for quick refractoriness test */ kill(already_did), assert(already_did(nil,nil)), /* need some assertion to avoid run-time complaint */ abolish('pd624 wme',1), /* otherwise we end up in a curious state?!!! */ kill('pd624 wme'), abolish(receives_answer,2), retractall(justification(Pat,'top level','You told me so')), assert('pd624 wme'([])), (retract(pd624_flag(_)) ; true), /* Used for single-step trace. See UTIL.PL */ initialise_back_door, /* in case of later extensions ! */ !. initialise_back_door :- allowable_back_door_initialise(X), /* back door utility defined? */ do_just_once(call(X)), /* then invoke it once */ fail. /* backtrack for others */ initialise_back_door. /* default success */ allow_back_door_initialise(Pred) :- /* to be used as a directive */ allowable_back_door_initialise(Pred); /* already there? do nothing */ assertz(allowable_back_door_initialise(Pred)). /* else add flag */ announce P :- 'pd624 write'(P),!. /* simple output of list of items */ /* PATCH 19-SEP-90: We now distinguish between 'continue' and 'go'. The former really leaves ALL internal state information alone (e.g. what rules have recently fired), and carries on forward chaining, if possible. The latter ('go') leaves working memory alone, as promised, but clears up various internal flags, so that a brand new run of forward chaining can be invoked with the current working memory (this is what most users expect anyway) */ continue :- 'pd624 wme'(A),!,forward_chain. continue :- assert('pd624 wme'([])),forward_chain. go :- part_initialise, /* get rid of hidden flags like 'already_did'...*/ forward_chain. the X of Y is Z:- prove(the X of Y is Z). the X of Y > Z:- prove(the X of Y > Z). the X of Y < Z:- prove(the X of Y < Z). all X of Y are Z:- prove(all X of Y are Z). wm:- 'pd624 write'(['The current contents of working memory are', nl,'the following : ',nl]), assert('wm counter'(0)), currentdb(X,Y), do_just_once((tab(5),write_db(X,Y),nl, retract('wm counter'(P)), New is P + 1, assert('wm counter'(New)) )), fail. wm:- retract('wm counter'(Number)), 'pd624 write'([nl,'A total of ',Number, ' current working memory elements were found.',nl]). write_db(X,false):- write(X),write(' is known to be false'),!. write_db(X,_):- write(X). /* this defines the de facto conflict resolution strategy, namely refractoriness recency specificity - - - applied in that order */ current_conflict_resolution_strategy([refractoriness,recency,specificity]). /* ==================== (5) F O R W A R D C H A I N I N G =========== */ /* ==================== Left-hand-side conditions =========== */ /* N.B. The forward chaining executive loop is stored separately in the file FC_EXEC.PL. It has been separated in order to keep this file (ENGINE.PL) a manageable size. */ /* ----- all_in_wm (sees whether all of its args are present in WM) ---- */ all_in_wm(A or B):- all_in_wm(A), !. all_in_wm(_ or B):- all_in_wm(B), !. all_in_wm(Pattern1 & Rest) :- !, when_enabled('show individual LHS in' for Pattern1), in_wm(Pattern1), when_enabled('show individual LHS out' for Pattern1), all_in_wm(Rest). all_in_wm(Pattern) :- /*singleton*/ when_enabled('show individual LHS in' for Pattern), in_wm(Pattern), when_enabled('show individual LHS out' for Pattern). /* ------------------------ Conflict resolution ------------------------- */ resolve_conflicts(List,Item,_,[]):- /* when you've exhausted conflict resolution */ first_filter(List,Item),!. /* choose the first */ /* first filter just takes the first item in the list. This can be achieved more efficiently, but is not for the sake of tracing. If tracing is deemed not to be important make the clause head of the first clause resolve_conflicts([H|_],Item,_,[]) instead. A second clause resolve_conflicts([],_,_,[]) will also be necessary to cater for an empty conflict set */ resolve_conflicts(Set,H,WME,[Strategy|Rest]):- DO_It =.. [Strategy,Set,WME,Newset], DO_It, resolve_conflicts(Newset,H,WME,Rest). first_filter([],(rule 'didnt find a winner' forward if 'no ifs' then 'no thens')):- !. first_filter([H|_],H). /* choose the first item */ /* conflict resolution strategies ---- user-modifiable */ /* if you design your own conflict resolution rules they must be of the form <name>(Input_set,Working_memory_elements,Output_set). The types of conflict resolution are refractoriness: a particular rule with a given set of instantiations is precluded from firing again recency: a weighting is done and only those rules whose pre conditions corespond most closely to the latest items in working memory are chosen specificity: the rules whose preconditions are most clearly specified (i.e. most left-hand-side conditions) are fired next */ refractoriness([],_,[]). refractoriness([(rule Rule forward if COND then Actions)|Rest],_,Output):- already_did(Rule,COND),!, when_enabled('show refractoriness' for Rule), refractoriness(Rest,_,Output). refractoriness([H|Rest],_,[H|Output]):- refractoriness(Rest,_,Output). recency([],_,[]). recency(Set,Wme,NewSet):- rank_candidates(Set,Wme,RankedSet), choose_most_likely_set(RankedSet,0,[],NewSet), when_enabled('show recency' for NewSet). rank_candidates([],_,[]). rank_candidates([(rule Rule forward if Cond then Actions)|Rest],Wme, [(Rank,(rule Rule forward if Cond then Actions))|NewRest]):- make_rank(Cond,Wme,0,Rank), rank_candidates(Rest,Wme,NewRest). make_rank(H or T,Wme,A,Rank):- make_rank(H,Wme,A,T1), make_rank(T,Wme,A,T2), Rank is T1 + T2. make_rank(H &T,Wme,A,B):- 'pd624 member'(H,Wme), A1 is A + 1, make_rank(T,Wme,A1,B). make_rank(_ & T,Wme,A,B):- make_rank(T,Wme,A,B). make_rank(A,Wme,B,C):- 'pd624 member'(A,Wme), C is B + 1 . make_rank(L,_,A,A). choose_most_likely_set([],_,A,A). choose_most_likely_set([(A,H)|Tail],Crit,Result,Set):- Crit > A, choose_most_likely_set(Tail,Crit,Result,Set). choose_most_likely_set([(A,H)|Tail],Crit,Result,Set):- Crit = A, choose_most_likely_set(Tail,Crit,[H|Result],Set). choose_most_likely_set([(A,H)|Tail],Crit,Result,Set):- A > Crit, choose_most_likely_set(Tail,A,[H],Set). specificity([],_,[]). /* when there are no applicable rules */ specificity(Set,Wme,Output):- specificity1(Set,Wme,Ranked_set), choose_most_likely_set(Ranked_set,0,[],Output), when_enabled('show specificity' for Output). specificity1([],_,[]). specificity1([(rule Rule forward if Cond then Actions)|Rest],_,[(Length,(rule Rule forward if Cond then Actions))|Set]):- 'pd624 length with disjunct check'(Cond,Length), /* see UTIL.PL */ specificity1(Rest,_,Set). /* if a rule has a disjunction on the LHS and both elements of that disjunction are true then it will appear multiple times in the conflict set e.g. rule eg forward if a(P) or b(P) then c(P) given a(1) and b(2) will result in both instantiations (i.e. c(1) and c(2)) appearing in the conflict set. HOWEVER if the rule is instead 'a or b then c', this will lead to the same rule in the conflict set twice, but via different routes. c'est la guerre */ /* ----------------------------- in_wm -------------------------------- */ in_wm(A or B):- in_wm(A). in_wm(A or B):- in_wm(B). in_wm(-- X) :- !, not(in_wm(X)). in_wm(deduce X) :- !, do_just_once(prove(X)). /* runs backward rules for that pattern! */ /* N.B. change above line to simply prove(X) if you disagree with the large comment below, i.e. if you want there to be multiple solutions whenever 'deduce' is used on the left hand side of a rule */ /* Notice that arbitrary backtracking is NOT allowed in consecutive calls to deduce which occur on the left hand side of a forward-chaining rule!!!!! -- the call to do_just_once above prevents this. Arbitrary backtracking is allowed within sequences of backward-chaining rules, however. In other words, suppose we had two rules such as the following: rule init forward if start then remove start & add [fred, is, happy] & add [mary, is, happy] & add [mary, likes, potatoes]. rule temp forward if -- start & deduce [X, is, happy] & deduce [X, likes, potatoes] then add [X, isa, happy_potato_eater]. Rule temp will never find a happy_potato_eater, because the first call to deduce will succeed with X = fred, but deduce [fred, likes, potatoes] will fail, and the first call will not be redone!! However, either of the next two temp rules would do the trick (along with the backward chaining rule 'potato_eater': rule temp2 forward if -- start & [X, is, happy] & [X, likes, potatoes] then add [X, isa, happy_potato_eater]. rule temp3 forward if -- start & deduce [X, isa, happy_potato_eater] then announce ['Hooray, I have discoverd a happy potato eater: ', X]. rule potato_eater backward if (because this is backward chaining..) [X, is, happy] & (arbitrary calls to deduce would be OK, also) [X, likes, potatoes] (arbitrary calls to deduce OK, also) then [X, isa, happy_pototo_eater]. */ /* execute prolog goal */ in_wm(prolog(X)):- !, X. /* If we look for, say, (the father of enrico is X), then we will not really find it in working memory, but instead invoke fetch/5 to do the real work inside the frame representation, just as we do in the case of backward chaining. Notice that fetch/5 on its own does pure frame accessing (possibly looking up the class hierarchy), but does NOT itself invoke the backward chainer */ in_wm(the Slot of Object is Filler) :- /* the basic frame form */ fetch(Object, Slot, Filler, [Object], _). in_wm(A receives_answer B):- A receives_answer B. in_wm(all X of Y are What) :- findall(Out,fetch(Y,X,Out,[Y],_),What). /* What is order sensitive,BEWARE! */ in_wm(the A of B > C):- do_just_once(prove(the A of B > C)). /* no backtracking!! */ in_wm(the A of B < C):- do_just_once(prove(the A of B < C)). /* N.B. change above line to simply prove(the A of B < C) (and similarly for 3 lines above!!!) if you disagree with the huge comment about a page earlier, i.e. if you want there to be multiple solutions whenever 'deduce' is used on the left hand side of a rule */ in_wm(A instance_of B):- A instance_of B with _whatever. in_wm(A subclass_of B):- A subclass_of B with _some_body. in_wm(Pattern) :- currentdb(Pattern,true). /* this is the basic WM assertion form */ /* Back door case, for extensions to MIKE */ in_wm(X):-allowable_prolog_lhs(X), !, call(X). /* 'Back door' enables us to extend the syntax of MIKE with calls to arbitrary lumps of Prolog: Note that the following two predicates are intended to be used as DIRECTIVES (analogous to ?-op(A,B,C)). The 'allow...' directive makes an assertion of the form 'allowable...' for testing by MIKE. */ /* If database assertion is present then ignore, else make assertion */ allow_prolog_lhs(Pattern) :- allowable_prolog_lhs(Pattern); assertz(allowable_prolog_lhs(Pattern)). allow_prolog_rhs(Pattern) :- allowable_prolog_rhs(Pattern);assertz(allowable_prolog_rhs(Pattern)). /* ================= (6) F O R W A R D C H A I N I N G =============== */ /* ================= Right-hand-side actions =============== */ perform(Action1 & Rest,List,Rule,Conds) :- !, do_just_once(perform1(Action1,A,Rule,Conds)), /* PATCH 11/1/90 */ perform(Rest,R,Rule,Conds), append(A,R,List). perform(Action,A,Rule,Conds) :- /* singleton case */ perform1(Action,A,Rule,Conds). perform1(prolog(Action),[],Rule,Conds) :- !, call(Action). perform1(remove Pattern,[],Rule,Conds) :- !, retract(currentdb(Pattern,true)). perform1(strategy List,[],Rule,Conds):- strategy List. /* Note the second argument to perform1 in the next three cases, which is the output of the new working memory elements. This is redundant storage because the user could have later referenced the answer to this question in one of two ways, either in the standard facet form, i.e. the A of B is C, or they could have checked the question answer specifically, in the form the A of B receives_answer C. Since all New Working Memory is used for is summation, redundancy will not effect the final outcome. For this reason, both forms can be added back to the conflict resolution component with safety. */ perform1((query the A of B receives_answer C), [the A of B receives_answer C,the A of B is C],Rule,Conds):- answer_vetting(C), (query the A of B receives_answer C), assert(justification((the A of B is C),Rule,'You told me so')). perform1((query the A of B is C receives_answer yes), [the A of B is C receives_answer yes, the A of B is C],Rule,Conds):- answer_vetting(C), (query the A of B is C receives_answer yes), assert(justification((the A of B is C),Rule,'You told me so')). perform1((query Quest receives_answer Ans), [Quest receives_answer Ans],Rule,Conds):- answer_vetting(C), (query Quest receives_answer Ans), assert(justification(Quest,Rule,'You told me so')). perform1(note (A instance_of B with C),[],Rules,Conds):- retract((A instance_of B with Body)), 'pd624 write'(['Warning : overwriting previous definition of ',A, nl,' instance of ',B,' with body ',Body,nl,' with the new body ', C,'. ',nl]), assert((A instance_of B with C)), assert(justification((A instance_of B with C),Rules,Conds)),!. perform1(note (A instance_of B with C),[A instance_of B],Rule,Conds):- assert((A instance_of B with C)), assert(justification((A instance_of B with C),Rule,Conds)), !. /* cut needed to stop overinstantiation in the following clauses in cases of failure */ perform1(note (A subclass_of B with C),[],Rules,Conds):- retract((A subclass_of B with Body)), 'pd624 write'(['Warning : overwriting previous definition of ',A, nl,' subclass of ',B,' with body ',Body,nl,' with the new body ', C,'. ',nl]), assert((A subclass_of B with C)), assert(justification((A subclass_of B with C),Rules,Conds)). perform1(note (A subclass_of B with C),[A subclass_of B],Rule,Conds):- assert((A subclass_of B with C)), !. /* cut needed to stop overinstantiation in the following clauses in cases of failure */ perform1(note the A of O is V,[the A of O is V],Rule,Conds):- store(O,A,V), assert(justification((the A of O is V),Rule,Conds)). perform1( (note X), _,Context,_) :- /* PATCH NEW ERROR MSG 20-SEP-90 */ not( X = ( the _ of _ is _ ) ), /* IF PATTERN IS NOT THIS ONE */ not( X = ( _ subclass_of _ with _ ) ), /* NOR THIS ONE... */ not( X = ( _ instance_of _ with _ ) ), /* NOR THIS ONE... */ nl, /* THEN IT IS A MISTAKE! */ write('ERROR... you have attempted the following'), 'pd624 tell me context'(Context),write(':'),nl, write(' note '),write(X),nl, write('HOWEVER, note can only be used with one of these 3 formats:'),nl, write(' a) note the X of Y is Z.'),nl, write( ' b) note (Obj1 instance_of Obj2 with Slot1:Filler1, Slot2:Filler2, ...).'), nl, write( ' c) note (Obj1 subclass_of Obj2 with Slot1:Filler1, Slot2:Filler2, ...).'), nl, write('(Most frames can be developed/saved in a file using a text editor.)'), nl, !, fail. perform1(add the A of O is V,[],Rule,Conds):- /* PATCH NEW ERROR MSG 11/1/90 */ write('ERROR: add can only be used for working memory patterns (use note)'), nl. perform1(add Pattern, [Pattern],Rule,Conds) :- /* identical to next case with keyword */ update_wm(Pattern), assert(justification(Pattern,Rule,Conds)). perform1(announce Pattern,[],Rule,Conds):- 'pd624 write'(Pattern),nl. perform1(the X of Y is Z,[],R,C) :- /* PATCH 14/6/90 */ 'pd624 write'(['ERROR: the ',X,' of ',Y,' is ',Z,nl, 'appeared on the right hand side of a rule. Use note if you want to',nl, 'change a frame, or prolog(the ',X,' of ',Y,' is <VAR>)',nl, 'to retrieve a slot filler in this context.',nl]), !. /* 'Back door' case... see code for allow_prolog_rhs above */ perform1(Action,[],Rule,Conds) :- allowable_prolog_rhs(Action), !, call(Action). perform1(Pattern,[Pattern],Rule,C) :- update_wm(Pattern), /* default case is to add Pattern to WM */ assert(justification(Pattern,Rule,C)). /* PATCH ADDED 11/1/90 */ perform1(P,[],Rule,C):- writel(['ERROR: the following Right-hand side of a rule failed',P]). update_wm(the Attribute of Object is Value) :- /* frame syntax? */ store(Object, Attribute, Value). /* utility to update frame representation */ update_wm(all Attributes of Object are [Value1 | Values]) :- store(Object, Attributes, [Value1|Values]). /* must unify with list! */ update_wm(OTHER) :- retract(currentdb(OTHER,TRUTH)), /* already there? then overwrite it */ !, assert(currentdb(OTHER,true)). update_wm(OTHER) :- /* must not have been there before, so add afresh */ assert(currentdb(OTHER,true)). 'pd624 tell me context'('top level') :- !. 'pd624 tell me context'(Name) :- ((rule Name forward if _ then _) ; (rule Name backward if _ then _)), write(' within rule '),write(Name), !. 'pd624 tell me context'(Name) :- write(' from '),write(Name).